numdig<-function(indata,algo="xxhash32"){
  dig<-digest(indata,algo=algo)
  out<-sum(sapply(1:nchar(dig),function(i){return(as.numeric(as.hexmode(substr(dig,i,i)))*16^(nchar(dig)-i))}),na.rm=TRUE)
  return(out)
}
getlast_string<-function(instring,sep=":",attribut="Place"){
  out<-NULL
  if(!is.null(instring)){
    out<-trimws(tail(strsplit(grep(attribut,instring,value=TRUE),sep)[[1]],1),which="both")
  }
  return(out)
}
cesignif<-function(cbase,dec.n=4)
{
  nve=Im(unlist(cbase))
  nve=esignif(nve,error=nve/10,dec.n)
  return(complex(real=esignif(Re(unlist(cbase)),error=Im(unlist(cbase)),dec.n=dec.n),imaginary=nve))
}

esignif<-function(base,error=0.01,dec.n=4)
{
  rv=base
  if(head(error,1)==0){
    if(dec.n!=0){ # Fehlerbehandlung, falls versehentlich dec.n==0 geliefert wird
      rv=signif(base,digits=dec.n)
    }else rv=signif(base,digits=4)
  }else{
    dec.n=max(1,round(log10(abs(base/error)))+1)
    rv=signif(base,digits=dec.n)
  }
  return(rv)
}

det.signif.int<-function(i,min=3,max=10){
  minmax<-min:max
  tout<- min(minmax[unlist(lapply(minmax,function(j){return(i==signif(i,j))}))],na.rm=TRUE)
  if(is.infinite(tout))tout<-max+1
  return(tout)
}
det.signif<-function(indata,min=3,max=10,cl=NULL){
  out<-NULL
  if(!is.null(indata)){
    if(is.null(cl)){
      out<-unlist(lapply(indata,det.signif.int,min=min,max=max))
    }else{
      clusterExport(cl,c("min","max","indata"))
      out<-unlist(parLapply(cl,indata,det.signif.int,min=min,max=max))
    }
  }
  return(out)
}
det.fracpart.int<-function(i,min=1,max=10){
  minmax<-min:max
  tout<-min(minmax[unlist(lapply(minmax,function(j){ti=i*10^j;return(ti==round(ti))}))],na.rm=TRUE)
  if(is.infinite(tout))tout<-max+1
  return(tout)
}
det.fracpart<-function(indata,min=1,max=10,cl=NULL){
  out<-NULL
  if(!is.null(indata)){
    if(is.null(cl)){
      out<-unlist(lapply(indata,det.fracpart.int,min=min,max=max))
    }else{
      clusterExport(cl,c("min","max","indata"))
      out<-unlist(parLapply(cl,indata,det.fracpart.int,min=min,max=max))
    }
  }
  return(out)
}
printvalerr<-function(cval)
{
  cval<-cesignif(cval)
  return(paste(Re(cval),Im(cval),sep=" ± "))
}

cweightedsd<-function(cv)
# calculates sd value of measdata with errors
{
  cv<-cv[!is.na(cv)]
 res<-sqrt(sum(Re(cv-cweightedmean(cv))^2/Im(cv))/sum(1/Im(cv)))
 return(res)
}

cweightedmean<-function(cv)
# calculates weighted mean value, where the weight is stored as imaginary value
{
  tcv=unlist(cv)
  tcv=tcv[!is.na(tcv)]
  val=Re(tcv)
  if(is.complex(cv)){  weight=1/Im(tcv)^2}else{weight=rep(1,length(val))}
  sta=1/sum(weight)
  m=sum(weight*val)*sta
  res=val-m
  
  sta=sqrt(sum(res^2)/(length(res)*max(1,(length(res)-1))))
  if(is.complex(cv)) sta<-sta+1/sqrt(sum(1/(Im(cv)^2),na.rm=TRUE)/(length(cv)*max(1,length(cv)-1)))
  return(complex(real=m,imaginary=sta))
}

calcmean<-function(cv)
{
  out=data.frame()
  for(l in dimnames(cv)[[1]]){
    out[l,"mean"]<-cweightedmean(cv[l,])
  }
  return(out)
}

calcerrordiv<-function(divident,divisor=1,depend=TRUE)
{
  udt=unlist(divident)
  uds=unlist(divisor)
  val=Re(udt)/Re(uds)
  err=abs(Im(udt)/Re(uds))+abs(Re(udt)*Im(uds)/(Re(uds)^2))
  if(!depend)err<-err/sqrt(2)
  return(complex(real=val,imaginary=err))
}
calcerrormul<-function(mul1,mul2=1,depend=TRUE)
{
  udt<-unlist(mul1)
  uds<-unlist(mul2)
  val<-Re(udt)*Re(uds)
  err<-abs(Im(udt)*Re(uds))+abs(Im(uds)*Re(udt))
  if(!depend)err<-err/sqrt(2)
  return(complex(real=val,imaginary=err))
}
calcerroradd<-function(add1,add2,dependent=TRUE)
{
  outr<-Re(add1)+Re(add2)
  iin<-Im(c(add1,add2))
  outi<-max(iin,na.rm=TRUE)
  if(length(iin>0)==2) outi<-(Im(add1)+Im(add2))/sqrt(2)
  return(complex(real=outr,imaginary=outi))
}

absIm<-function(cin)
{
  return(complex(real=Re(cin),imaginary=abs(Im(cin))))
}

testvalue.grubbs<-function(alpha,count){
# berechnet Testgröße für Grubbs-Ausreisser-Test
  tv<-(qt(1-alpha/2,count-2))^2
  return((count-1)/sqrt(count*((count-2)/tv+1)))
}

# original grubbs outlier test for complex values
outlier.grubbs.complex<-function(indata,alpha=0.1) return(switch(is.complex(indata)+1,outlier.grubbs(indata=Re(indata),alpha=alpha,merror=NA),outlier.grubbs(indata=Re(indata),alpha=alpha,merror=Im(indata))))
# original grubbs outlier test
outlier.grubbs<-function(indata,alpha=0.1,merror=NA) return(outlier.grubbsbase(indata,alpha,merror,bmedian=FALSE,bnalimov=FALSE))
# robust grubbs test with median instead of mean value
outlier.grubbs.robust<-function(indata,alpha=0.1,merror=NA) return(outlier.grubbsbase(indata,alpha,merror,bmedian=TRUE,bnalimov=FALSE))
# Grubbs test with Nalimov-correction
outlier.nalimov<-function(indata,alpha=0.1,merror=NA) return(outlier.grubbsbase(indata,alpha,merror,bmedian=FALSE,bnalimov=TRUE))
# robust grubbs test with nalimov-correction
outlier.nalimov.robust<-function(indata,alpha=0.1,merror=NA) return(outlier.grubbsbase(indata,alpha,merror,bmedian=TRUE,bnalimov=TRUE))

outlier.grubbsbase<-function(indata,alpha=0.1,merror=NA,bmedian=FALSE,bnalimov=TRUE,bdebug=FALSE){
# outlier detection grubbs with robust and/or Nalimov modification
# indata: list of measurements
# alpha: significanse level
# merror: error of each measurement
# bmedian: uses median instead of mean values
# bnalimov: uses a correction factor depending on count of measures
  count<-sum(!is.na(indata))
  nod<-indata
  cnalimov=1
  if(bnalimov) cnalimov<-sqrt(count/(count-1))
  if(count>2){ # Grubbs-Test ist nur für mehr als 2 Messdaten sinnvoll
    tv<-testvalue.grubbs(alpha,count)
    if(bmedian){
      xm<-median(indata,na.rm=TRUE)
      xd<-median(abs(indata-xm),na.rm=TRUE)
    }else{
      if(sum(!is.na(merror))==0){
        xm<-mean(indata,na.rm=TRUE)
        xd<-sd(indata,na.rm=TRUE)
      }else{
        xm<-weighted.mean(indata,1/merror,na.rm=TRUE)
        xd<-sqrt(weighted.mean((indata-xm)^2,1/merror,na.rm=TRUE))
        if(bdebug)print(paste(xm,xd))
      }
    }
    if(xd>0){
      gv<-cnalimov*abs(indata-xm)/(xd*tv)
      if(max(gv,na.rm=TRUE)>1){
        nrange<-(gv==max(gv,na.rm=TRUE))
        indata[nrange]<-NA
        if(sum(!is.na(merror))==0) merror<-NA else merror[nrange]<-NA
        nod<-outlier.grubbs(indata,alpha,merror)
      }
    }
  }
  return(nod)
}


getmode <- function(v) {
  uniqv <- unique(v)
  uniqv[which.max(tabulate(match(v, uniqv)))]
}

calc.diff<-function(indata,startvalue=0)
{
  out<-NULL
  if(!is.na(indata)){
    out<-c(startvalue,diff(indata))
  }
  return(out)
}

testvalue.neumann<-function(indata){
  # Pr�fwert nach Formel http://www.reiter1.com/Glossar/Neumann_Trendtest.htm
  out<-NULL
  if(!is.null(indata)){
    indata<-indata[!is.na(indata)]
    out<-(sum(diff(indata)^2,na.rm=TRUE)/(length(indata)-1))/var(indata)
  }
  return(out)
}

refvalue.neumann<-function(indata,alpha=0.05){
  # Korrigierter Pr�fwert nach http://www.reiter1.com/Glossar/Neumann_Trendtest.htm
  out<-NULL
  if(!is.null(indata)){
    indata<-indata[!is.na(indata)]
    out<-2*(1-qnorm(1-alpha)*sqrt((length(indata)-2)/(length(indata)^2-1)))
  }
}

trendtest.neumann<-function(indata,alpha=0.05){
  out<-NULL
  if(!is.null(indata)){
    out<-testvalue.neumann(indata)/refvalue.neumann(indata,alpha=alpha)
  }
  return(out)
}

